home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
fpkpas92.zip
/
SRCRTL.ZIP
/
RTL
/
DOS
/
TEXT.PPI
< prev
next >
Wrap
Text File
|
1997-07-02
|
15KB
|
445 lines
{***************************************************************************}
{ Text Output }
{***************************************************************************}
const
{ Support 16 Vector Fonts }
{ To load more fonts, increase this }
maxfonts = 16;
fontdivs:array[0..maxfonts]of integer=
(1,4,3,4,4,4,4,4,4,3,3,1,1,1,1,1,1);
type
pbyte = ^byte;
{$PACKRECORDS 1}
pfontdata = ^tfontdata;
tfontdata = record
filetyp : char;
nr_chars : word;
undefined1 : byte;
value_first_char : byte;
undefined2 : array[1..3] of byte;
dist_origin_top : shortint;
dist_origin_baseline : shortint;
dist_origin_bottom : shortint;
undefined3 : array[1..5] of byte;
end;
{$PACKRECORDS NORMAL}
tfontrec = record
name : string[8];
data : pointer;
header : pfontdata;
offsets : pword;
widths : pbyte;
instr : pbyte;
end;
var
fonts : array[1..maxfonts] of tfontrec;
installedfonts : longint;
{$I FONT.PPI}
{ returns true if p points to valid font file }
function testfont(p : pointer) : boolean;
begin
testfont:=(pchar(p)^='P') and
(pchar(p+1)^='K') and
(pchar(p+2)^=#8) and
(pchar(p+3)^=#8);
end;
{ set help data for font with number font }
{ pointer data must already be set }
function setupfont(font : word) : integer;
begin
setupfont:=grOK;
fonts[font].header:=fonts[font].data+$80;
if fonts[font].header^.filetyp<>'+' then
begin
setupfont:=grInvalidFont;
exit;
end;
fonts[font].offsets:=fonts[font].data+$90;
fonts[font].widths:=pbyte(fonts[font].offsets+fonts[font].header^.nr_chars*2);
fonts[font].instr:=fonts[font].widths+fonts[font].header^.nr_chars;
end;
function InstallUserFont(const FontFileName : string) : integer;
begin
_graphresult:=grOk;
{ grapf mode must be set! }
{ is enough place for a font ? }
if installedfonts=maxfonts then
begin
_graphresult:=grError;
exit;
end;
inc(installedfonts);
fonts[installedfonts].name:=FontFileName;
fonts[installedfonts].data:=nil;
InstallUserFont:=installedfonts;
end;
function RegisterBGIfont(font : pointer) : integer;
var
hp : pbyte;
b : word;
name : string[12];
begin
{ not yet guaranteed thad everything works }
RegisterBGIfont:=grInvalidFontNum;
{ graphmode must not be set ! }
if testfont(font) then
begin
hp:=pbyte(font);
{ search end of text header }
while hp^<>$1a do
hp:=hp+1;
{ jump to start of name }
hp:=hp+3;
{ Namen lesen }
name:='';
for b:=0 to 3 do
name:=name+char((hp+b)^);
{ search correct font }
for b:=1 to installedfonts do
begin
if fonts[b].name=name then
begin
fonts[b].data:=font;
RegisterBGIfont:=grOK;
RegisterBGIfont:=setupfont(b);
end;
end;
end
else
RegisterBGIFont:=grInvalidFont;
end;
procedure GetTextSettings(var TextInfo : TextSettingsType);
begin
_graphresult:=grOk;
if not isgraphmode then
begin
_graphresult:=grnoinitgraph;
exit;
end;
textinfo:=akttextinfo;
end;
procedure OutText(const TextString : string);
var x,y:integer;
begin
_graphresult:=grOk;
if not isgraphmode then
begin
_graphresult:=grnoinitgraph;
exit;
end;
x:=curx; y:=cury;
OutTextXY(curx,cury,TextString);
{ if output is done horizontal and left justified }
{ update graph cursor }
if (akttextinfo.direction=HorizDir) and
(akttextinfo.horiz=LeftText) then
inc(x,textwidth(TextString));
curx:=x; cury:=y; { LineTo changes GrafikCursor !! }
end;
procedure outtext(const charakter : char);
var s:string;
x,y:integer;
begin
s:=charakter;
_graphresult:=grOk;
if not isgraphmode then
begin
_graphresult:=grnoinitgraph;
exit;
end;
x:=curx; y:=cury;
OutTextXY(curx,cury,s);
{ wenn horizontal und linksb ndig ausgegeben wird, dann }
{ Grafikcursor nachf hren }
{ if (akttextinfo.direction=HorizDir) and
(akttextinfo.horiz=LeftText) then }
inc(x,textwidth(s));
curx:=x; cury:=y; { LineTo manipuliert den GrafikCursor !! }
end;
procedure OutTextXY(x,y : integer;const TextString : string);
var
b1,b2 : shortint;
c,instr,mask : byte;
i,j,k : longint;
oldvalues : linesettingstype;
nextpos : word;
xpos,ypos,offs: longint;
FontPtr : Pointer;
begin
_graphresult:=grOk;
if not isgraphmode then
begin
_graphresult:=grnoinitgraph;
exit;
end;
{ compute real x- and y- start position }
if akttextinfo.direction=horizdir then
begin
case akttextinfo.horiz of
centertext : XPos:=(textwidth(textstring) shr 1);
lefttext : XPos:=0;
righttext : XPos:=textwidth(textstring);
end;
case akttextinfo.vert of
centertext : YPos:=(textheight(textstring) shr 1);
bottomtext : YPos:=0;
toptext : YPos:=textheight(textstring);
end;
end else
begin
case akttextinfo.horiz of
centertext : XPos:=(textheight(textstring) shr 1);
lefttext : XPos:=0;
righttext : XPos:=textheight(textstring);
end;
case akttextinfo.vert of
centertext : YPos:=(textwidth(textstring) shr 1);
bottomtext : YPos:=0;
toptext : YPos:=textwidth(textstring);
end;
end;
X:=X-XPos; Y:=Y+YPos;
XPos:=X; YPos:=Y;
if akttextinfo.font=DefaultFont then begin
y:=y-6;
c:=textwidth(textstring) div 8 - 1; { Char counter }
FontPtr:=@defaultfontdata;
for i:=0 to c do begin
offs:=ord(textString[i+1]) shl 3; { Offset of Chars in Data }
for j:=0 to 7 do begin
mask:=$80;
b1:=defaultfontdata[offs+j]; { Offset of Char line }
xpos:=i shl 3+x;
for k:=0 to 7 do begin
if (b1 and mask) <> 0 then putpixel(xpos+k,j+y,aktcolor);
mask:=mask shr 1;
end;
end;
end;
end else
begin
{ Linienstil setzen }
getlinesettings(oldvalues);
setlinestyle(solidln,oldvalues.pattern,normwidth);
if akttextinfo.direction=vertdir then xpos:=xpos + Textheight(textstring);
curx:=xpos; cury:=ypos; x:=xpos; y:=ypos;
for i:=1 to length(textstring) do
begin
c:=byte(textstring[i]);
c:=c-fonts[akttextinfo.font].header^.value_first_char;
{ definiertes Zeichen ? }
if (c<0) or (c>=fonts[akttextinfo.font].header^.nr_chars) then continue;
nextpos:=fonts[akttextinfo.font].offsets[c];
while true do
begin
b1:=fonts[akttextinfo.font].instr[nextpos];
nextpos:=nextpos+1;
b2:=fonts[akttextinfo.font].instr[nextpos];
nextpos:=nextpos+1;
instr:=((b1 and $80) shr 6)+((b2 and $80) shr 7);
b1:=b1 and $7f;
b2:=b2 and $7f;
{ Vorzeichen erweitern }
if (b1 and $40)<>0 then b1:=b1 or $80;
if (b2 and $40)<>0 then b2:=b2 or $80;
{ neue Stiftposition berechnen und skalieren }
if akttextinfo.direction=VertDir then
begin
xpos:=x-((b2*aktmultx) div aktdivx);
ypos:=y-((b1*aktmulty) div aktdivy);
end
else
begin
xpos:=x+((b1*aktmultx) div aktdivx) ;
ypos:=y-((b2*aktmulty) div aktdivy) ;
end;
case instr of
0 : break;
2 : begin curx:=xpos; cury:=ypos; end;
3 : begin line(curx,cury,xpos,ypos);
curx:=xpos; cury:=ypos;
end;
end;
end;
if akttextinfo.direction=VertDir then
y:=y-(fonts[akttextinfo.font].widths[c]*aktmultx div aktdivx)
else
x:=x+(fonts[akttextinfo.font].widths[c]*aktmultx div aktdivx) ;
end;
setlinestyle( oldvalues.linestyle, oldvalues.pattern, oldvalues.thickness);
end;
end;
procedure outtextxy(x,y: Integer;const charakter : char);
var s:string;
begin
s:=charakter;
outtextXY(x,y,s);
end;
function TextHeight(const TextString : string) : word;
begin
_graphresult:=grOk;
if not isgraphmode then
begin
_graphresult:=grnoinitgraph;
exit;
end;
if akttextinfo.font=DefaultFont
then TextHeight:=6+akttextinfo.charsize
else
TextHeight:=(((fonts[akttextinfo.font].header^.dist_origin_top-
fonts[akttextinfo.font].header^.dist_origin_bottom) * aktmulty) div aktdivy) ;
end;
function TextWidth(const TextString : string) : word;
var i,x : Integer;
c : byte;
begin
_graphresult:=grOk; x:=0;
if not isgraphmode then
begin
_graphresult:=grnoinitgraph;
exit;
end;
if akttextinfo.font = Defaultfont then
TextWidth:=length(TextString)*8*akttextinfo.charsize
else begin
for i:=1 to length(TextString) do begin
c:=byte(textstring[i]);
dec(c,fonts[akttextinfo.font].header^.value_first_char);
{ defined character ? }
if (c<0) or (c>=fonts[akttextinfo.font].header^.nr_chars) then
continue;
x:=x+fonts[akttextinfo.font].widths[c];
end;
TextWidth:=((x * aktmultx) div aktdivx) ;
end;
end;
procedure SetTextJustify(horiz,vert : word);
begin
_graphresult:=grOk;
if not isgraphmode then
begin
_graphresult:=grnoinitgraph;
exit;
end;
if (horiz<0) or (horiz>2) or
(vert<0) or (vert>2) then
begin
_graphresult:=grError;
exit;
end;
akttextinfo.horiz:=horiz;
akttextinfo.vert:=vert;
end;
procedure SetTextStyle(font,direction : word;charsize : word);
var
f : file;
begin
_graphresult:=grOk;
if not isgraphmode then
begin
_graphresult:=grnoinitgraph;
exit;
end;
{ test validity of parameter }
if font>installedfonts then
begin
_graphresult:=grInvalidFontNum;
exit;
end;
akttextinfo.font:=font;
if (direction<>HorizDir) and (direction<>VertDir) then
direction:=HorizDir;
akttextinfo.direction:=direction;
akttextinfo.charsize:=charsize;
if (charsize <> usercharsize) then begin
aktmultx:=charsize;
aktdivx:=fontdivs[font];
aktmulty:=charsize;
aktdivy:=fontdivs[font];
end;
{ load font file ? }
if (font>0) and not assigned(fonts[font].data) then
begin
assign(f,bgipath+fonts[font].name+'.CHR');
reset(f,1);
if ioresult<>0 then
begin
_graphresult:=grFontNotFound;
akttextinfo.font:=DefaultFont;
exit;
end;
getmem(fonts[font].data,filesize(f));
if not assigned(fonts[font].data) then
begin
_graphresult:=grNoFontMem;
akttextinfo.font:=DefaultFont;
exit;
end;
blockread(f,fonts[font].data^,filesize(f));
if testfont(fonts[font].data) then
_graphresult:=setupfont(font)
else
begin
_graphresult:=grInvalidFont;
akttextinfo.font:=DefaultFont;
freemem(fonts[font].data,filesize(f));
end;
close(f);
end;
end;
procedure SetUserCharSize(Multx,Divx,Multy,Divy : word);
begin
_graphresult:=grOk;
if not isgraphmode then
begin
_graphresult:=grnoinitgraph;
exit;
end;
aktmultx:=Multx;
aktdivx:=Divx;
aktmulty:=Multy;
aktdivy:=Divy;
end;